home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Doc / Reference / index.stk < prev    next >
Encoding:
Text File  |  1995-07-18  |  3.8 KB  |  130 lines
  1. (define main 0)
  2. (define aux 1)
  3.  
  4. (define pretty-print (lambda (expr) (format #t "Pretty: ~S\n" expr) expr))
  5.  
  6. (define every?
  7.     (lambda (test . lists)
  8.       (let scan ((tails lists))
  9.     (if (member #t (map null? tails))             ;(any null? lists)
  10.         #t
  11.         (and (apply test (map car tails))
  12.          (scan (map cdr tails)))))))
  13.  
  14. (define (make-entry key font main/aux page)
  15.   (list key font main/aux page))
  16. (define (entry-key x) (car x))
  17. (define (entry-font x) (cadr x))
  18. (define (entry-main/aux x) (caddr x))
  19. (define (entry-page x) (cadddr x))
  20.  
  21. (define *database* '())
  22.  
  23. (define (index-entry key font main/aux page)
  24.   (set! *database*
  25.         (cons (make-entry (string-lower key)
  26.                           font
  27.                           main/aux
  28.                           page)
  29.               *database*))
  30.   #t)
  31.  
  32. (define (create-index p)
  33.   (define (loop)
  34.     (if (null? *database*)
  35.         'done
  36.         (begin (process-key (collect-entries) p)
  37.                (loop))))
  38.   (set! *database*
  39.         (sort *database*
  40.               (lambda (x y)
  41.                 (string<? (entry-key x)
  42.                           (entry-key y)))))
  43.   (loop))
  44.  
  45. (define (collect-entries)
  46.   (define (loop key entries)
  47.     (cond ((null? *database*) entries)
  48.           ((string=? key (entry-key (car *database*)))
  49.            (let ((x (car *database*)))
  50.              (set! *database* (cdr *database*))
  51.              (loop key (cons x entries))))
  52.           (else entries)))
  53.   (loop (caar *database*) '()))
  54.  
  55. (define (process-key entries p)
  56.   (let ((entries (sort entries entry<?)))
  57.     (if (not (consistent? entries))
  58.         (begin (display "Inconsistent entries:")
  59.                (newline)
  60.                (pretty-print entries)
  61.                (newline)
  62.                (newline)))
  63.     (let ((key (entry-key (car entries)))
  64.           (font (entry-font (car entries)))
  65.           (main? (entry-main/aux (car entries)))
  66.           (pages (remove-duplicates (map entry-page entries))))
  67.       (if main?
  68.           (write-entries key font (car pages) (cdr pages) p)
  69.           (write-entries key font #f pages p)))))
  70.  
  71. (define (entry<? x y)
  72.   (let ((x1 (entry-main/aux x))
  73.         (y1 (entry-main/aux y)))
  74.     (or (< x1 y1)
  75.         (and (eq? x1 y1)
  76.              (< (entry-page x) (entry-page y))))))
  77.  
  78. (define (consistent? entries)
  79.   (let ((x (car entries)))
  80.     (let ((key (entry-key x))
  81.           (font (entry-font x)))
  82.       (every? (lambda (x)
  83.                 (and (string=? key (entry-key x))
  84.                      (string=? font (entry-font x))
  85.                      ;(eq? aux (entry-main/aux x))
  86.                      ))
  87.               (cdr entries)))))
  88.  
  89. (define (remove-duplicates x)
  90.   (define (loop x y)
  91.     (cond ((null? x) (reverse y))
  92.           ((memq (car x) y) (loop (cdr x) y))
  93.           (else (loop (cdr x) (cons (car x) y)))))
  94.   (loop (cdr x) (list (car x))))
  95.  
  96. (define *last-key* "%")
  97. (define *s1* (string-append "\\item{" (list->string '(#\\))))
  98. (define *s2* "{")
  99. (define *s3* "}}\\dotfill\\ ")
  100. (define *semi* "\; ")
  101. (define *comma* ", ")
  102.  
  103. (define (write-entries key font main pages p)
  104.   (if (and (char-alphabetic? (string-ref key 0))
  105.            (not (char=? (string-ref *last-key* 0)
  106.                         (string-ref key 0))))
  107.       (begin (display "\\indexspace" p)
  108.          (newline p)
  109.          (display "{\\vskip3mm\\LARGE " p)
  110.          (display (string-upper (substring key 0 1)) p)
  111.          (display "\\nopagebreak}\\" p)
  112.              (newline p)))
  113.   (set! *last-key* key)
  114.   (display (string-append *s1* font *s2* key *s3*) p)
  115.   (if main
  116.       (begin (write main p)
  117.              (if (not (null? pages))
  118.                  (display *semi* p))))
  119.   (if (not (null? pages))
  120.       (begin (write (car pages) p)
  121.              (for-each (lambda (page)
  122.                          (display *comma* p)
  123.                          (write page p))
  124.                        (cdr pages))))
  125.   (newline p))
  126.  
  127. (load "manual.idx")
  128. (define p (open-output-file "index.tex"))
  129. (create-index p)
  130.